home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / examples / old / menu.l < prev    next >
Encoding:
Text File  |  1989-07-12  |  14.3 KB  |  398 lines
  1. ;;; -*- Mode:Lisp; Package:CLUE-EXAMPLES; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. (in-package 'clue-examples :use '(lisp xlib clos cluei))
  20.  
  21.  
  22. (export '( menu                    ; Contact class
  23.       multiple-menu                ; Contact class
  24.       spring-loaded-menu            ; Contact class
  25.       menu-choose                ; Menu building utility
  26.       popup-choose                ; Popup menu building utility
  27.       cascade-choose            ; Spring-loaded menu building utility
  28.       position-over-mouse            ; Position a contact over the mouse
  29.       position-right-of            ; Position a contact for popup
  30.       contact-root-position            ; Calculate contact position relative to root
  31.       ))
  32.  
  33. ;; THROW is a special form, wrap it in a function
  34. (defun do-throw (tag value) (throw tag value))
  35.  
  36.  
  37. (defcontact menu (composite)
  38.   ((ordering :type (or (member :first :last) function)
  39.          :initform :last
  40.          :accessor menu-insert-ordering)
  41.    (border-width :type card16 :initform 0)
  42.    )
  43.   (:resources
  44.     (cursor :initform "arrow"))
  45.   (:documentation "An array of buttons or labels")
  46.   )
  47.  
  48. (defmethod add-child ((self menu) contact &key)
  49.   "Put CONTACT on its parent's list of managed contacts"
  50.   (with-slots ((manager-children children)
  51.            (manager-ordering ordering)) self
  52.     (let ((children manager-children)
  53.       (ordering manager-ordering))
  54.       (unless (member contact children)
  55.     (case ordering
  56.       (:first (push contact children))
  57.       (:last (setf children (nconc children (list contact))))
  58.       (otherwise
  59.        (if (or (null children)
  60.            (null (funcall ordering contact (car children))))
  61.            (push contact children)
  62.          (do ((c children (cdr c)))
  63.          ((null (cdr c))
  64.           (setf (cdr c) (list contact)))
  65.            ;; Insert contact when ordering "lessp" predicate returns nil
  66.            (unless (funcall ordering contact (cadr c))
  67.          (setf (cdr c) (list* contact (cdr c)))
  68.          (return nil))))))
  69.     (setf manager-children children)))))
  70.  
  71. (defmethod change-layout ((menu menu) &optional newly-managed)
  72.   (declare (ignore newly-managed))
  73.   (let* ((children (composite-children menu))
  74.      (width 0)
  75.      (height (contact-border-width (first children))))
  76.     (dolist (item children)
  77.       (when (managed-p item)
  78.     (let ((border-width (contact-border-width item)))
  79.       (move item border-width height)
  80.       (setq width (max width (+ (contact-width item) border-width border-width))
  81.         height (+ height (contact-height item) border-width)))))
  82.     (change-geometry menu :width width :height height :accept-p t)
  83.     (setq width (contact-width menu)) ;; in case we didn't get what we wanted
  84.     (dolist (item (composite-children menu))
  85.       (when (managed-p item)
  86.     (resize item width (contact-height item) (contact-border-width item))))))
  87.  
  88. (defmethod manage-geometry ((parent menu) contact x1 y1 width1 height1 border-width1 &key)
  89.   ;; Geometry Management for menus.
  90.   ;; This version only manages a single column.
  91.   ;; It needs to be extended to do general row/column arrays.
  92.   (declare (values success-p x y width height border-width))
  93. ;  (declare (type contact contact)
  94. ;       (type (or null int16) x1 y1)
  95. ;       (type (or null card16) width1 height1 border-width1)
  96. ;       (values success-p x y width height border-width))
  97.   (let* ((previous (previous-sibling contact));; Find the contact BEFORE this one
  98.      (x 0)
  99.      (y 0)
  100.      (parent-width (contact-width parent))
  101.      (parent-height (contact-height parent))
  102.      (width (or width1 (contact-width contact)))
  103.      (height (or height1 (contact-height contact)))
  104.      (border-width 0)
  105.      (success t))
  106.     (declare (type (or null contact) previous)
  107.          (type (or null int16) x y)
  108.          (type (or null card16) width height border-width)
  109.          (type boolean success))
  110.     (when previous
  111.       (setq y (+ (contact-y previous) (contact-height previous))))
  112.     (setq width (max width parent-width))
  113.     (when (or (> width parent-width)
  114.           (> (+ y height) parent-height))
  115.       (change-geometry parent :width width :height (+ y height) :accept-p t)
  116.       (when (> width parent-width)
  117.     (setq parent-width (contact-width parent)
  118.           width parent-width)
  119.     (dolist (child (composite-children parent))
  120.       (when (managed-p child)
  121.         (resize child width (contact-height child) (contact-border-width child))))))
  122.     (setq success (and (or (null x1) (= x x1))
  123.                (or (null y1) (= y y1))
  124.                (or (null width1) (= width width1))
  125.                (or (null height1) (= height height1))
  126.                (or (null border-width1) (= border-width border-width1))))
  127. ;;    (PV success x y width height border-width)
  128.     (values success x y width height border-width)))
  129.  
  130.  
  131. ;;;-----------------------------------------------------------------------------
  132. ;;; MULTIPLE-MENU
  133.  
  134. (defcontact multiple-menu (menu)
  135.   ()
  136.   (:documentation "A menu that can have more then one item selected at once."))
  137.  
  138. (defmethod add-child :after ((self multiple-menu) contact &key)
  139.   ;; Alter the event-translations of button children.
  140.   (when (typep contact 'button)
  141.     (add-event contact :button-release 'notify)))
  142.  
  143. ;;;-----------------------------------------------------------------------------
  144. ;;; SPRING-LOADED-MENU
  145.  
  146. (defcontact spring-loaded-menu (menu)
  147.   ()
  148.   (:documentation "A menu where a mouse button is always pressed and
  149.  an item is selected when the button is released."))
  150.  
  151. (defmethod add-child :after ((self spring-loaded-menu) contact &key)
  152.   ;; Alter the event-translations of button children.
  153.   (when (typep contact 'button)
  154.     (add-event contact :button-press '(action-display :select t)) ;; Should never get to this
  155.     (add-event contact :button-release 'notify)
  156.     (add-event contact :enter-notify '(action-display :select t))
  157.     (add-event contact :leave-notify 'slide-right '(action-display :select nil))))
  158.  
  159. (defmethod leave-cascade ((self spring-loaded-menu))
  160.   (apply-callback self :leave))
  161.  
  162. (defevent spring-loaded-menu :leave-notify leave-cascade) 
  163.  
  164. ;;;-----------------------------------------------------------------------------
  165. ;;; easy to use interface
  166.  
  167. ;;; Helper function (we gota get rid of this crock - its slow...)
  168. #+comment
  169. (defun filter-options (allowable options)
  170.   ;; Return those options in allowable
  171.   ;; allowable is a list of keywords, options is a list of keyword/value pairs
  172.   (do ((option options (cddr option))
  173.        (result nil))
  174.       ((endp option) result)
  175.     (when (member (car option) allowable :test #'eq)
  176.       (setq result (list* (car option) (cadr option) result)))))
  177.  
  178. (defun menu-exit (&rest values)
  179.   "Exit from the current popup-menu returning VALUES"
  180.   (when (car values) ;; when not aborting
  181.     (do-throw (contact-mode *contact*) (values-list values))))
  182.  
  183. (defmethod popup-abort ((contact menu))
  184.   ;; Throw out of a popup menu.
  185.   ;; Don't throw when there's no popup above our level.
  186.   (let ((mode (contact-super-mode contact)))
  187.     (when mode
  188.       (apply-callback contact :abort)
  189.       (do-throw mode nil))))
  190.  
  191. (defun cascade-exit (contact)
  192.   (let ((mode (contact-mode contact)))
  193.     (when mode
  194.       (apply-callback contact :abort)
  195.       (do-throw mode nil))))
  196.  
  197. (defevent menu (:enter-notify :ancestor :virtual :nonlinear :nonlinear-virtual)
  198. ;; Abort on any entry-notify EXCEPT :ancestor, which
  199. ;;   may happen when the mouse slides between a menu-item and
  200. ;;   the gap between a menu item and the edge of the menu.
  201.   popup-abort) ;; Throw to the NEXT level catch
  202.  
  203.  
  204. (defun menu-choose (parent alist &rest options &key label
  205.             (mode :exclusive)
  206.             (handler #'menu-exit)
  207.             (menu-type 'menu) (item-type 'button)
  208.             (justify :center) (font "fg-18") &allow-other-keys)
  209.   "Display a menu on parent from alist.
  210.  Alist entries are (stringable . options) where options are keyword-value pairs:
  211.  :title string
  212.  :font font
  213.  :justify (member :left :center :right)
  214.  :select (or function list)"
  215.   
  216.   
  217.   (let ((menu (apply #'make-contact menu-type :parent parent :allow-other-keys t options)))
  218.     (when label
  219.       (let ((args (and (consp label) (cdr label)))
  220.         (title (if (consp label) (car label) label)))
  221.     (apply #'make-contact 'label :parent menu :name 'label :title title args)))
  222.     (add-mode menu mode 'ignore-action)
  223.     (dolist (entry alist)
  224.       (let ((name entry)
  225.         (args nil)
  226.         (item-title entry))
  227.     (when (consp entry)
  228.       (setq name (car entry)
  229.         item-title name
  230.         args (cdr entry)))
  231.     (when (stringp name)
  232.       (setq name (make-symbol (string-upcase name))))
  233.     (do* ((arg args (cddr arg))
  234.           (value (second arg) (second arg))
  235.           (item-justify justify)
  236.           (item-font font)
  237.           (item-doc nil)
  238.           (events nil)
  239.           (callback :select)
  240.           (callbacks nil)
  241.           (options nil))
  242.          ((endp arg)
  243.           ;; Set default event handler
  244.           (unless (assoc :select callbacks :test #'eq)
  245.         (push (if (consp handler)
  246.               `(:select ,(cons (first handler)
  247.                        (append (rest handler)
  248.                            (list (if (consp entry)
  249.                                                              (first entry)
  250.                                                              entry)))))
  251.               `(:select ,(list handler (if (consp entry)
  252.                                                        (first entry)
  253.                                                        entry))))
  254.  
  255. ;              `(:select ,@(append handler (list entry)))
  256. ;              `(:select ,handler ,entry))
  257.               callbacks))
  258.           ;; Add item to menu
  259.           (let ((item (apply #'make-contact
  260.                  item-type
  261.                  :parent menu
  262.                  :name name
  263.                  :title item-title
  264.                  :callbacks callbacks
  265.                  :justify item-justify
  266.                  :font item-font
  267.                  :documentation item-doc
  268.                  options
  269.                  )))
  270.         ;; Add events (if any) to item
  271.         (dolist (event events)
  272.           (add-event item `(:button-release ,@(first event))
  273.                  `(notify ,(second event))
  274.                  '(action-display :select nil)))))
  275.       ;; Gather arguments
  276.       (ecase (car arg)
  277.         (:cascade (push `(:cascade ,value) callbacks)
  278.               (setq options (append '(:cursor "sb_right_arrow") options)))
  279.         (:justify (setq item-justify value))
  280.         (:title (setq item-title value))
  281.         (:font (setq item-font value))
  282.         (:documentation (setq item-doc value))
  283.         (:select
  284.          (if (consp value)
  285.          (push `(,callback ,(list* (first value) (rest value))) callbacks)
  286.          (push `(,callback ,(list value)) callbacks)))
  287.  
  288. ;         (push `(,callback ,@value) callbacks)
  289. ;         (push `(,callback ,value) callbacks)))
  290.         (:event (setq callback (gensym))
  291.             (unless (consp value) (setq value (list value)))
  292.             (push `(,value ,callback) events))))))
  293.     menu))
  294.  
  295. (defun popup-choose (display alist &rest options &key  x y  spring-loaded &allow-other-keys)
  296.   "Popup a menu on parent from alist.
  297.  Returns NIL if aborted (pointer moved outside the menu),
  298.  else the value returned by the :SELECT callback of the selected button.
  299.  Alist entries are (stringable . options) where options are keyword-value pairs:
  300.  :font font
  301.  :justify (member :left :center :right)
  302.  :select (or function list)"
  303.   ;; Get the parent
  304.                         ;(when (and (null parent) (null *contact*))
  305.                         ;  (xlib::required-arg parent))
  306.   ;; Create the menu and popup-shell
  307.   (let* ((popup (make-contact
  308.           'top-level-shell :parent display
  309.           :x x :y y 
  310.           :spring-loaded spring-loaded
  311.           :name (gensym) ;; debug
  312.           
  313.           ))
  314.      (menu-type (if spring-loaded 'spring-loaded-menu 'menu)))
  315.     ;; Create MENU, which is a child of POPUP.
  316.     ;; The default action for MENU's item's is a throws 
  317.     ;; which returns the item to the top-level popup.
  318.     (apply #'menu-choose popup alist
  319.        :menu-type menu-type
  320.        :mode (if spring-loaded :spring-loaded :exclusive)
  321.        options)
  322.     ;; Default position is centered over the mouse
  323.     (add-callback popup :map #'(lambda () (unless (and x y)
  324.                         (position-over-mouse popup))))
  325.     ;;
  326.     ;; The event-loop
  327.     (unwind-protect (catch popup
  328.                       (setf (contact-state popup) :mapped)
  329.               (loop (process-next-event (contact-display popup)))
  330.               ) 
  331.       (destroy popup)
  332.       )))
  333.  
  334.  
  335. (defun cascade-choose (alist &rest options)
  336.   "Display a menu on parent from alist.
  337.  Alist entries are (stringable . options) where options are keyword-value pairs:
  338.  :font font
  339.  :justify (member :left :center :right)
  340.  :select (or function list)"
  341.   (apply 'popup-choose alist :spring-loaded t options))
  342.  
  343. (defun position-over-mouse (contact)
  344.   "Position CONTACT centered over the mouse.
  345.  Ensures CONTACT remains inside its parent."
  346.   (declare (type contact contact))
  347.   (let ((parent (contact-parent contact))
  348.     (width (contact-width contact))
  349.     (height (contact-height contact)))
  350.     ;; Ensure parent is realized
  351.     (unless (realized-p parent)
  352.       (error "Parent of ~s not realized." contact))
  353.     ;; Find mouse position relative to parent
  354.     (multiple-value-bind (x y)
  355.     (query-pointer parent)
  356.       ;; Center contact over mouse
  357.       (decf x (floor width 2))
  358.       (decf y (floor height 2))
  359.       (when (minusp x) (setq x 0))
  360.       (when (minusp y) (setq y 0))
  361.       ;; Ensure contact is within its parent
  362.       (let ((dx (- (contact-width parent) (+ x width)))
  363.         (dy (- (contact-height parent) (+ y height))))
  364.     (when (minusp dx) (setq x (max (+ x dx) 0)))
  365.     (when (minusp dy) (setq y (max (+ y dy) 0))))
  366.       ;; Move the contact
  367.       (change-geometry contact :x x :y y))))
  368.  
  369. (defun contact-root-position (contact)
  370.   "Return the position of CONTACT relative to the root."
  371.   (declare (type contact contact)
  372.        (values x y))
  373.   (do ((p (contact-parent contact) (contact-parent p))
  374.        (x (contact-x contact))
  375.        (y (contact-y contact)))
  376.       ((null p) (values x y))
  377.     (incf x (contact-x p))
  378.     (incf y (contact-y p))))
  379.  
  380. (defun position-right-of (contact relative-to)
  381.   "Position CONTACT (usually a cascading menu) to the right of
  382.   RELATIVE-TO (usually CONTACT's parent).
  383.  CONTACT is constrained to be within the root window."
  384.   (declare (type contact contact relative-to))
  385.   (let ((width (contact-width contact))
  386.     (height (contact-height contact))
  387.     x y)
  388.     (multiple-value-setq (x y)
  389.       (contact-root-position relative-to))
  390.     (setq x (+ x (contact-width relative-to) -20)
  391.       y y)
  392.     (let* ((root (contact-root contact))
  393.        (dx (- (contact-width root) (+ x width 5)))
  394.        (dy (- (contact-height root) (+ y height))))
  395.       (when (minusp dx) (setq x (max (+ x dx) 0)))
  396.       (when (minusp dy) (setq y (max (+ y dy) 0))))
  397.       ;; Move the contact
  398.       (change-geometry contact :x x :y y)))